home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / Quick Spy196755162001.psc / modMain.bas < prev    next >
Encoding:
BASIC Source File  |  2001-05-17  |  15.2 KB  |  435 lines
  1. Attribute VB_Name = "modMain"
  2. '*************************************************************
  3. 'Module:        modMain
  4. 'Description:   Public functions/variables for Quick Spy
  5. 'Date:          May 11, 2001
  6. 'Last Updated:  May 16, 2001
  7. 'Developer:     Shannon Harmon (shannonh@theharmonfamily.com)
  8. 'Info:          Feel free to use any of the routines in your
  9. '               own package, but you may not distribute/sell
  10. '               Quick Spy in whole or part without my consent.
  11. '               Copyright 2001, Shannon Harmon - All rights reserved!
  12. '*************************************************************
  13. Option Explicit
  14.  
  15. Public Const PS_SOLID = 0
  16. Public Const BS_HOLLOW = 1
  17. Public Const HS_SOLID = 8
  18. Public Const RO_COPYPEN = 13
  19. Public Const DT_CENTER = &H1
  20.  
  21. Public Const EM_SETPASSWORDCHAR = &HCC
  22. Public Const EM_GETPASSWORDCHAR = &HD2
  23.  
  24. Public Const ERROR_INVALID_WINDOW = 101
  25. Public Const ERROR_NO_WINDOW_SELECTED = 102
  26. Public Const ERROR_INVALID_COLOR = 103
  27. Public Const ERROR_NO_CAPTURE = 104
  28. Public Const ERROR_SAVING_IMAGE = 105
  29. Public Const ERROR_CANNOT_USE_WITHIN_APP = 106
  30.  
  31. Public Const HWND_NOTOPMOST = -2
  32. Public Const HWND_TOPMOST = -1
  33.  
  34. Public Const RASTERCAPS As Long = 38
  35. Public Const RC_PALETTE As Long = &H100
  36. Public Const SIZEPALETTE As Long = 104
  37.  
  38. Public Const RDW_ALLCHILDREN = &H80
  39. Public Const RDW_ERASE = &H4
  40. Public Const RDW_ERASENOW = &H200
  41. Public Const RDW_FRAME = &H400
  42. Public Const RDW_INTERNALPAINT = &H2
  43. Public Const RDW_INVALIDATE = &H1
  44. Public Const RDW_NOCHILDREN = &H40
  45. Public Const RDW_NOERASE = &H20
  46. Public Const RDW_NOFRAME = &H800
  47. Public Const RDW_NOINTERNALPAINT = &H10
  48. Public Const RDW_UPDATENOW = &H100
  49. Public Const RDW_VALIDATE = &H8
  50. Public Const RDW_FLAGS = RDW_ALLCHILDREN Or RDW_ERASENOW Or _
  51.              RDW_INTERNALPAINT Or RDW_INVALIDATE Or _
  52.              RDW_FRAME Or RDW_UPDATENOW
  53.  
  54. Public Const SRCCOPY = &HCC0020
  55.  
  56. Public Const SWP_NOSIZE = 1
  57. Public Const SWP_NOMOVE = 2
  58.  
  59. Public Type POINTAPI
  60.   x As Long
  61.   y As Long
  62. End Type
  63.  
  64. Public Type RECT
  65.   Left As Long
  66.   Top As Long
  67.   Right As Long
  68.   Bottom As Long
  69. End Type
  70.  
  71. Public Type PALETTEENTRY
  72.   peRed As Byte
  73.   peGreen As Byte
  74.   peBlue As Byte
  75.   peFlags As Byte
  76. End Type
  77.  
  78. Public Type LOGPALETTE
  79.   palVersion As Integer
  80.   palNumEntries As Integer
  81.   palPalEntry(255) As PALETTEENTRY
  82. End Type
  83.  
  84. Public Type GUID
  85.   Data1 As Long
  86.   Data2 As Integer
  87.   Data3 As Integer
  88.   Data4(7) As Byte
  89. End Type
  90.  
  91. Public Type PictureBMP
  92.   Size As Long
  93.   Type As Long
  94.   lnghBMP As Long
  95.   lnghPal As Long
  96.   Reserved As Long
  97. End Type
  98.  
  99. Public Type LOGBRUSH
  100.   lbStyle As Long
  101.   lbColor As Long
  102.   lbHatch As Long
  103. End Type
  104.  
  105. Public Enum CaptureArea
  106.   CA_UNKNOWN = 0
  107.   CA_16 = 1
  108.   CA_32 = 2
  109.   CA_48 = 3
  110.   CA_CUSTOM = 4
  111. End Enum
  112.  
  113. Global CA_Cur As CaptureArea
  114. Global picZoomSave As Picture
  115.  
  116. Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
  117. Public Declare Function CoCreateGuid Lib "OLE32.DLL" (pGuid As GUID) As Long
  118. Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
  119. Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  120. Public Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
  121. Public Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
  122. Public Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
  123. Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
  124. Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  125. Public Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
  126. Public Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
  127. Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
  128. Public Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
  129. Public Declare Function GetDesktopWindow Lib "user32" () As Long
  130. Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long
  131. Public Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
  132. Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
  133. Public Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
  134. Public Declare Function GetROP2 Lib "gdi32" (ByVal hdc As Long) As Long
  135. Public Declare Function GetTickCount Lib "kernel32" () As Long
  136. Public Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
  137. Public Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
  138. Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
  139. Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
  140. Public Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
  141. Public Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT, ByVal bErase As Long) As Long
  142. Public Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
  143. Public Declare Function IsWindowEnabled Lib "user32" (ByVal hwnd As Long) As Long
  144. Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PictureBMP, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
  145. Public Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long
  146. Public Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
  147. Public Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
  148. Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
  149. Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  150. Public Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal lnghPalette As Long, ByVal bForceBackground As Long) As Long
  151. Public Declare Function SetROP2 Lib "gdi32" (ByVal hdc As Long, ByVal nDrawMode As Long) As Long
  152. Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
  153. Public Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
  154. Public Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
  155. Public Declare Function StringFromGUID2 Lib "ole32" (ByRef lpGUID As GUID, ByVal lpStr As String, ByVal lSize As Long) As Long
  156. Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
  157.  
  158. Public Function GetSaveFileName(ByVal hwndOwner As Long) As String
  159.   Dim FileDialog As clsFileDialog
  160.   Set FileDialog = New clsFileDialog
  161.   Static strInitDir As String
  162.   
  163.   With FileDialog
  164.     If strInitDir <> "" Then .InitialDir = strInitDir
  165.     .DefaultExt = "bmp"
  166.     .DialogTitle = App.Title & " - Save Captured Image"
  167.     .Filter = "Bitmap files (*.bmp)|*.bmp"
  168.     .FilterIndex = 0
  169.     .Flags = FlePathMustExist + FleOverWritePrompt
  170.     .hWndParent = hwndOwner
  171.     .MaxFileSize = 255
  172.     If .Show(False) Then
  173.       strInitDir = .FileName
  174.       GetSaveFileName = .FileName
  175.     Else
  176.       GetSaveFileName = ""
  177.     End If
  178.   End With
  179.   
  180.   Set FileDialog = Nothing
  181. End Function
  182.  
  183. Public Function GetGUID() As String
  184.   Dim udtGUID As GUID
  185.   Dim strGUID As String * 80
  186.   Dim lRet As Long
  187.   
  188.   If CoCreateGuid(udtGUID) = 0 Then
  189.     lRet = StringFromGUID2(udtGUID, strGUID, 80)
  190.     If lRet <> 0 Then
  191.       strGUID = StrConv(strGUID, vbFromUnicode)
  192.       GetGUID = Mid(strGUID, 1, lRet - 1)
  193.     End If
  194.   End If
  195. End Function
  196.  
  197. Public Function GetRectFromPoints(pt1 As POINTAPI, pt2 As POINTAPI, rc As RECT) As Long
  198.   On Error GoTo PROC_ERR
  199.   
  200.   rc.Left = IIf(pt1.x < pt2.x, pt1.x, pt2.x)
  201.   rc.Top = IIf(pt1.y < pt2.y, pt1.y, pt2.y)
  202.   rc.Right = IIf(pt1.x > pt2.x, pt1.x, pt2.x)
  203.   rc.Bottom = IIf(pt1.y > pt2.y, pt1.y, pt2.y)
  204.   GetRectFromPoints = 1
  205.     
  206. PROC_EXIT:
  207.   Exit Function
  208.   
  209. PROC_ERR:
  210.   GetRectFromPoints = 0
  211.   Resume PROC_EXIT
  212. End Function
  213.  
  214. Public Function DrawRect(dc As Long, rc As RECT, Optional ByVal intWidth As Integer = 1, Optional ByVal lngColor As OLE_COLOR = 0&) As Long
  215.   On Error GoTo PROC_ERR
  216.   Dim hPen As Long
  217.   Dim hPenOld As Long
  218.   Dim hBrush As Long
  219.   Dim hBrushOld As Long
  220.   Dim hBrushPrev As Long
  221.   Dim lngROP2ModeOld As Long
  222.   Dim lngResult As Long
  223.   Dim lb As LOGBRUSH
  224.   
  225.   If dc = 0 Then GoTo PROC_EXIT
  226.   
  227.   hPen = CreatePen(PS_SOLID, intWidth, lngColor)
  228.   hPenOld = SelectObject(dc, hPen)
  229.   If hPenOld = 0 Then GoTo PROC_EXIT
  230.   
  231.   lb.lbHatch = HS_SOLID
  232.   lb.lbStyle = BS_HOLLOW
  233.   lb.lbColor = 0& 'Not using, hollow rectangle:)
  234.   
  235.   If GetROP2(dc) <> RO_COPYPEN Then
  236.     lngROP2ModeOld = SetROP2(dc, RO_COPYPEN)
  237.   End If
  238.   
  239.   hBrush = CreateBrushIndirect(lb)
  240.   hBrushOld = SelectObject(dc, hBrush)
  241.   lngResult = Rectangle(dc, rc.Left, rc.Top, rc.Right, rc.Bottom)
  242.   
  243.   DrawRect = 1
  244.     
  245. PROC_EXIT:
  246.   If lngROP2ModeOld <> 0 Then SetROP2 dc, lngROP2ModeOld
  247.   If hBrushOld <> 0 Then SelectObject dc, hBrushOld
  248.   If hPenOld <> 0 Then SelectObject dc, hPenOld
  249.   If hBrush <> 0 Then DeleteObject hBrush
  250.   If hPen <> 0 Then DeleteObject hPen
  251.   Exit Function
  252.  
  253. PROC_ERR:
  254.   DrawRect = 0
  255.   Resume PROC_EXIT
  256. End Function
  257.  
  258. Public Function ResizeRect(rc As RECT, ByVal iPixels As Integer) As Long
  259.   On Error GoTo PROC_ERR
  260.  
  261.   With rc
  262.     .Left = .Left - iPixels
  263.     .Top = .Top - iPixels
  264.     .Right = .Right + iPixels
  265.     .Bottom = .Bottom + iPixels
  266.   End With
  267.  
  268.   ResizeRect = 1
  269.  
  270. PROC_EXIT:
  271.   Exit Function
  272.  
  273. PROC_ERR:
  274.   ResizeRect = 0
  275.   Resume PROC_EXIT
  276. End Function
  277.  
  278. Public Sub Pause(ByVal lMillSecs As Long)
  279.   On Error GoTo PROC_ERR
  280.   Dim lTime As Long
  281.   lTime = GetTickCount()
  282.  
  283.   Do While GetTickCount() - lTime < lMillSecs
  284.     DoEvents
  285.   Loop
  286.  
  287. PROC_EXIT:
  288.   Exit Sub
  289.   
  290. PROC_ERR:
  291.   Resume PROC_EXIT
  292. End Sub
  293.  
  294. Public Function CaptureRect(ByVal dc As Long, rc As RECT, pic As Picture) As Long
  295.   On Error GoTo PROC_ERR
  296.   Dim lnghdcMem As Long
  297.   Dim lnghBMP As Long
  298.   Dim lnghBMPPrev As Long
  299.   Dim lngRetval As Long
  300.   Dim lnghPal As Long
  301.   Dim lnghPalPrev As Long
  302.   Dim lngRasterCapsScreen As Long
  303.   Dim lngPaletteScreen As Long
  304.   Dim lngPaletteSizeScreen As Long
  305.   Dim LogPal As LOGPALETTE
  306.   Const clngVGASize As Long = 256
  307.  
  308.   lngRasterCapsScreen = GetDeviceCaps(dc, RASTERCAPS)
  309.   lngPaletteScreen = lngRasterCapsScreen And RC_PALETTE
  310.   lngPaletteSizeScreen = GetDeviceCaps(dc, SIZEPALETTE)
  311.   lnghdcMem = CreateCompatibleDC(dc)
  312.   lnghBMP = CreateCompatibleBitmap(dc, rc.Right - rc.Left, rc.Bottom - rc.Top)
  313.   lnghBMPPrev = SelectObject(lnghdcMem, lnghBMP)
  314.  
  315.   If lngPaletteScreen Then
  316.     If (lngPaletteSizeScreen = clngVGASize) Then
  317.       LogPal.palVersion = &H300
  318.       LogPal.palNumEntries = clngVGASize
  319.       lngRetval = GetSystemPaletteEntries(dc, 0, clngVGASize, LogPal.palPalEntry(0))
  320.       lnghPal = CreatePalette(LogPal)
  321.       lnghPalPrev = SelectPalette(lnghdcMem, lnghPal, 0)
  322.       lngRetval = RealizePalette(lnghdcMem)
  323.     End If
  324.   End If
  325.  
  326.   lngRetval = BitBlt(lnghdcMem, 0, 0, rc.Right - rc.Left, _
  327.               rc.Bottom - rc.Top, dc, rc.Left, rc.Top, vbSrcCopy)
  328.   
  329.   lnghBMP = SelectObject(lnghdcMem, lnghBMPPrev)
  330.  
  331.   If lngPaletteScreen Then
  332.     If (lngPaletteSizeScreen = clngVGASize) Then
  333.       lnghPal = SelectPalette(lnghdcMem, lnghPalPrev, 0)
  334.     End If
  335.   End If
  336.  
  337.   lngRetval = DeleteDC(lnghdcMem)
  338.   CaptureRect = CreatePictureFromBitmap(lnghBMP, lnghPal, pic)
  339.   
  340. PROC_EXIT:
  341.   Exit Function
  342.  
  343. PROC_ERR:
  344.   Set pic = LoadPicture()
  345.   CaptureRect = 0
  346. End Function
  347.  
  348. Public Function CreatePictureFromBitmap(ByVal lnghBMP As Long, ByVal lnghPal As Long, pic As Picture) As Long
  349.   On Error GoTo PROC_ERR
  350.   Dim lngRetval As Long
  351.   Dim picBMP As PictureBMP
  352.   Dim IPic As IPicture
  353.   Dim IID_IDispatch As GUID
  354.  
  355.   With IID_IDispatch
  356.     .Data1 = &H20400
  357.     .Data4(0) = &HC0
  358.     .Data4(7) = &H46
  359.   End With
  360.  
  361.   With picBMP
  362.     .Size = Len(picBMP)
  363.     .Type = vbPicTypeBitmap
  364.     .lnghBMP = lnghBMP
  365.     .lnghPal = lnghPal
  366.   End With
  367.  
  368.   lngRetval = OleCreatePictureIndirect(picBMP, IID_IDispatch, 1, IPic)
  369.   Set pic = IPic
  370.   CreatePictureFromBitmap = 1
  371.   
  372. PROC_EXIT:
  373.   Exit Function
  374.   
  375. PROC_ERR:
  376.   Set pic = LoadPicture()
  377.   CreatePictureFromBitmap = 0
  378. End Function
  379.  
  380. Public Function WebColor(ByVal lngColor As Long) As String
  381.   If lngColor < vbBlack Or lngColor > vbWhite Then
  382.     Err.Raise vbObjectError + ERROR_INVALID_COLOR, "WebColor", _
  383.               LoadResString(ERROR_INVALID_COLOR)
  384.   Else
  385.     WebColor = Format$(Hex(RGBRed(lngColor)), "00") & _
  386.                Format$(Hex(RGBGreen(lngColor)), "00") & _
  387.                Format$(Hex(RGBBlue(lngColor)), "00")
  388.   End If
  389. End Function
  390.  
  391. Public Function RGBRed(ByVal lngColor As Long) As Integer
  392.   If lngColor < vbBlack Or lngColor > vbWhite Then
  393.     Err.Raise vbObjectError + ERROR_INVALID_COLOR, "RGBRed", _
  394.               LoadResString(ERROR_INVALID_COLOR)
  395.   Else
  396.     RGBRed = lngColor And &HFF
  397.   End If
  398. End Function
  399.  
  400. Public Function RGBGreen(ByVal lngColor As Long) As Integer
  401.   If lngColor < vbBlack Or lngColor > vbWhite Then
  402.     Err.Raise vbObjectError + ERROR_INVALID_COLOR, "RGBGreen", _
  403.               LoadResString(ERROR_INVALID_COLOR)
  404.   Else
  405.     RGBGreen = ((lngColor And &H100FF00) / &H100)
  406.   End If
  407. End Function
  408.  
  409. Public Function RGBBlue(ByVal lngColor As Long) As Integer
  410.   If lngColor < vbBlack Or lngColor > vbWhite Then
  411.     Err.Raise vbObjectError + ERROR_INVALID_COLOR, "RGBBlue", _
  412.               LoadResString(ERROR_INVALID_COLOR)
  413.   Else
  414.     RGBBlue = (lngColor And &HFF0000) / &H10000
  415.   End If
  416. End Function
  417.  
  418. Public Function GetVBColorName(ByVal lngColor As Long, Optional ByVal strNA As String) As String
  419.   Dim strCol As String
  420.   
  421.   Select Case lngColor
  422.     Case vbBlack:                   strCol = "vbBlack"
  423.     Case vbRed:                     strCol = "vbRed"
  424.     Case vbGreen:                   strCol = "vbGreen"
  425.     Case vbYellow:                  strCol = "vbYellow"
  426.     Case vbBlue:                    strCol = "vbBlue"
  427.     Case vbMagenta:                 strCol = "vbMagenta"
  428.     Case vbCyan:                    strCol = "vbCyan"
  429.     Case vbWhite:                   strCol = "vbWhite"
  430.     Case Else:                      strCol = strNA
  431.   End Select
  432.   
  433.   GetVBColorName = strCol
  434. End Function
  435.